home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
utils
/
imd110.zip
/
IMAGEID.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-12
|
12KB
|
433 lines
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
UNIT ImageID;
(* A Pascal unit which will determine a few major image types.
To use this unit, simply call the function as follows:
FileID := IsImage (FileName.Ext, width, height, colors, GIFlite);
IF FileID = 'wBMP' THEN ...
Returns a null string if unable to identify, otherwise one of these:
wBMP, GIF87a, GIF89a, JPEG, PCX, PiNG
*)
INTERFACE
FUNCTION IsImage (CONST fFile: STRING; VAR iWidth, iHeight: LONGINT; VAR iColors, GIFLite: STRING): STRING;
VAR
ImageType : STRING;
ImageWidth : LONGINT;
ImageHeight : LONGINT;
ImageColors : STRING;
GIFl : STRING;
IMPLEMENTATION
FUNCTION LPad (bstr: STRING; CONST len: BYTE): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := #32 + bstr;
LPad := bstr;
END;
FUNCTION GetBMPInfo (CONST FName: STRING): BOOLEAN;
{ This procedure takes the name of an existing file as input, and tries
to write the header contents of the file on screen. }
TYPE
BMPheader =
RECORD
bfType : WORD;
bfSize : LONGINT;
bfReserved : LONGINT; {Moet 0 zijn}
bfOffBits : LONGINT;
biSize : LONGINT;
biWidth : LONGINT;
biHeight : LONGINT;
biPlanes : WORD; {Moet 1 zijn}
biBitCount : WORD; {1,4,8,24}
biCompression : LONGINT;
biSizeImage : LONGINT; {in bytes}
biXPelsPerMeter : LONGINT;
biYPelsPerMeter : LONGINT;
biClrUsed : LONGINT;
biClrImportant : LONGINT;
END;
LABEL
SkipBMP;
VAR
ImageFile: FILE;
BitMapHeader : BMPheader;
Colors : STRING[4];
BytesRead : WORD;
IsBMP : BOOLEAN;
BEGIN
IsBMP := FALSE;
Assign (ImageFile, FName);
Reset (ImageFile, 1);
BlockRead (ImageFile, BitMapHeader, SizeOf (BitMapHeader), BytesRead);
Close (ImageFile);
IF (IOResult = 0) AND (BytesRead = SizeOf(BitMapHeader)) THEN
WITH BitMapHeader DO
BEGIN
IF NOT (bfType = 19778) OR ((bfReserved <> 0) AND (biPlanes <> 1)) THEN
Goto SkipBMP;
CASE (biBitCount) OF
1 : Colors := '2';
4 : Colors := '16';
8 : Colors := '256';
24: Colors := '16m'; {2^24}
ELSE
Goto SkipBMP;
END;
IsBMP := TRUE;
IF biClrUsed <> 0 THEN
Str (biClrUsed, Colors);
ImageType := 'wBMP';
ImageWidth := biWidth;
ImageHeight := biHeight;
ImageColors := (LPad(colors,5))+' ]';
END;
SkipBMP:
GetBMPInfo := IsBMP;
END;
PROCEDURE CheckGIFlite (CONST fname: STRING; FPos: LONGINT; OFFSET: WORD);
VAR
giflite: ARRAY [1..7] OF CHAR;
blocklabel: ARRAY [1..2] OF CHAR;
ImageFile: FILE;
BytesRead : WORD;
BEGIN
Assign (ImageFile, fname);
Reset (ImageFile, 1);
FillChar (giflite [1], SizeOf(giflite), #32);
FillChar (blocklabel [1], SizeOf(blocklabel), #32);
Seek (ImageFile, FPos + (3 * OFFSET));
IF (IOResult = 0) THEN
BEGIN
BlockRead (ImageFile, blocklabel, SizeOf(blocklabel), BytesRead);
IF (IOResult = 0) AND (BytesRead = SizeOf(blocklabel)) AND (blocklabel = #33#255) THEN BEGIN
Seek (ImageFile, FilePos(ImageFile) + 1);
BlockRead (ImageFile, giflite, SizeOf(giflite), BytesRead);
END;
END;
Close (ImageFile);
IF (IOResult = 0) AND (BytesRead = SizeOf(giflite)) AND (giflite = 'GIFLITE')
THEN GIFl := '(LITE)';
END;
FUNCTION GetGIFInfo (CONST FName: STRING): BOOLEAN;
TYPE
Image_Rec = RECORD
i_version : ARRAY [1..6] OF CHAR;
i_width,
i_height : WORD;
i_colors : BYTE;
END;
VAR
ImageData: Image_Rec;
ImageFile: FILE;
rez : WORD;
FPos: LONGINT;
BytesRead : WORD;
IsGIF: BOOLEAN;
BEGIN
IsGIF := FALSE;
Assign (ImageFile, FName);
Reset (ImageFile, 1);
IF (IOResult = 0) THEN
BEGIN
BlockRead (ImageFile, ImageData, SizeOf (ImageData), BytesRead);
FPos := FilePos (ImageFile);
Close (ImageFile);
IF (IOResult = 0) AND (BytesRead = SizeOf (ImageData)) THEN
WITH ImageData DO BEGIN
IF (Copy (i_version, 1, 3) = 'GIF') THEN
BEGIN
IsGIF := TRUE;
rez := (2 SHL (i_colors AND 7)); {formula from SWAG}
ImageType := i_version;
ImageWidth := i_Width;
ImageHeight := i_Height;
Str (rez:5,ImageColors);
ImageColors := ImageColors + ' ]';
CheckGIFlite (FName, FPos+2, rez) {FPos+2 accounts for "background"}
END;
END;
END;
GetGIFInfo := IsGIF;
END;
FUNCTION GetJPGInfo (CONST FName: STRING): BOOLEAN;
{Checks if file FName is a (true) JPeg/JFIF file and extracts the
height and width (in pixels) of the image, and determines if image is color}
VAR
ImageFile : FILE;
ImageData : ARRAY [1..11] OF CHAR;
BytesRead : WORD;
Index : INTEGER;
Height, Width, Color: WORD;
IsJPG : BOOLEAN;
BlockLength : LongInt;
BEGIN
IsJPG := FALSE;
Assign (ImageFile, FName);
Reset (ImageFile, 1);
FillChar (ImageData [1], SizeOf(ImageData), #0);
BlockRead (ImageFile, ImageData [1], SizeOf(ImageData), BytesRead);
IF (IOResult = 0) AND
(BytesRead = SizeOf(ImageData)) AND
(ImageData [1] = #$FF) AND {JFIF marker: $FF SOI $FF App0}
(ImageData [2] = #$D8) AND
(ImageData [3] = #$FF) AND
(ImageData [4] = #$E0) AND
{ (ImageData [5] = length - MSB and }
{ (ImageData [6] = length - LSB and }
(ImageData [7] = 'J') AND
(ImageData [8] = 'F') AND
(ImageData [9] = 'I') AND
(ImageData [10] = 'F') AND
(ImageData [11] = #0)
THEN IsJPG := TRUE;
IF IsJPG THEN
BEGIN {We have a JPeg/JFIF File!}
Seek(ImageFile, 4); {Restore to position right after first block sig}
BlockLength := 256*Ord(ImageData[5]) + Ord(ImageData[6]);
REPEAT {Search for SOF marker}
Seek (ImageFile, FilePos(ImageFile) + BlockLength);
BlockRead (ImageFile, ImageData [1], 4, BytesRead);
BlockLength := 256*Ord(ImageData[3]) + Ord(ImageData[4]) - 2;
UNTIL (BytesRead <> 4) OR (ImageData [2] = #$C0);
IF ImageData[2]=#$C0 THEN BEGIN
Seek (ImageFile, FilePos(ImageFile) - 2);
BlockRead (ImageFile, ImageData [1], SizeOf(ImageData), BytesRead);
IF BytesRead = SizeOf(ImageData) THEN
BEGIN
Index := 0;
{ ImageData[Index] = first SOF marker
Index + 1 = length high byte \ length of APP0 data!
Index + 2 = length low byte /
Index + 3 = data precision - colors (?)
Index + 4 = height high byte \ heigth of picture
Index + 5 = height low byte /
Index + 6 = width high byte \ width of picture
Index + 7 = width low byte / }
Height := WORD (Ord (ImageData [Index + 4]) * 256) + Ord (ImageData [Index + 5]);
Width := WORD (Ord (ImageData [Index + 6]) * 256) + Ord (ImageData [Index + 7]);
Color := Ord (ImageData [Index + 8]);
END;
END;
END;
IF IsJPG THEN
BEGIN
ImageType := 'JPEG';
ImageWidth := Width;
ImageHeight := Height;
IF Color > 1
THEN ImageColors := (' color]')
ELSE ImageColors := (' grey ]');
END;
Close (ImageFile);
GetJPGInfo := IsJPG;
END;
PROCEDURE Swap32 (VAR LongVar : LONGINT); ASSEMBLER;
ASM {Swap a 32 bit variable (MSB<->LSB).}
les SI, LongVar
mov AX, ES: [SI]
mov DX, ES: [SI + 2]
xchg AL, DH
xchg AH, DL
mov ES: [SI], AX
mov ES: [SI + 2], DX
END {Swap32};
PROCEDURE Process_IHDR (VAR ImageFile: FILE);
VAR
PNGHead : RECORD {see the PNG spec, draft #9}
Width, Height : LONGINT;
BitsPerSample : BYTE;
ColorType : BYTE;
CM, Filter, IL : BYTE
END;
Colors : String[3];
BytesRead : WORD;
BEGIN {Process_IHDR}
FillChar (PNGHead, SizeOf (PNGHead), #0);
BlockRead (ImageFile, PNGHead, SizeOf (PNGHead), BytesRead);
IF (IOResult = 0) AND (BytesRead = SizeOf (PNGHead)) THEN
WITH PNGHead DO BEGIN
Swap32 (Width);
Swap32 (Height);
CASE (BitsPerSample) OF
1 : Colors := '2';
4 : Colors := '16';
8 : Colors := '256';
24: Colors := '16m'; {2^24}
ELSE Colors := '???'
END;
ImageType := 'PiNG';
ImageWidth := Width;
ImageHeight := Height;
IF ColorType > 1
THEN ImageColors := LPad(colors,5)+'c]'
ELSE ImageColors := LPad(colors,5)+'g]';
END;
END {Process_IHDR};
FUNCTION GetPNGInfo (CONST Fname: STRING): BOOLEAN;
CONST
PNG_Magic : ARRAY [0..7] OF CHAR = #137'PNG'#13#10#26#10;
MaxBytes = 1000;
VAR
BufMag : ARRAY [0..7] OF CHAR;
ImageFile : FILE;
ImageData : ARRAY [1..MaxBytes] OF CHAR;
BytesRead : WORD;
Index : INTEGER;
Found,
IsPNG : BOOLEAN;
BEGIN
IsPNG := FALSE;
Assign (ImageFile, FName);
Reset (ImageFile, 1);
BlockRead (ImageFile, BufMag, SizeOf(BufMag), BytesRead);
IF (IOResult = 0) AND (BytesRead = SizeOf(BufMag)) THEN
BEGIN
IF (BufMag = PNG_Magic) THEN
BEGIN
BlockRead (ImageFile, ImageData [1], MaxBytes, BytesRead);
index := 0;
Found := FALSE;
REPEAT
Inc (index);
IF (ImageData [index] = 'I') AND
(ImageData [index+1] = 'H') AND
(ImageData [index+2] = 'D') AND
(ImageData [index+3] = 'R')
THEN FOUND := TRUE;
UNTIL Found OR (index + 10 > BytesRead);
If Found Then Begin
IsPNG := TRUE;
Seek(ImageFile, Index+3+SizeOf(BufMag)); {Seek is zero based}
Process_IHDR (ImageFile);
End;
END;
END;
Close (ImageFile);
GetPNGInfo := IsPNG;
END {Main};
FUNCTION GetPCXInfo (CONST FName: STRING): BOOLEAN;
TYPE
PCXHeader = RECORD
Signature : CHAR;
Version : CHAR;
Encoding : CHAR;
BitsPerPixel : CHAR;
XMin, YMin,
XMax, YMax : INTEGER;
HRes, VRes : INTEGER;
Palette : ARRAY [0..47] OF BYTE;
Reserved : CHAR;
Planes : CHAR;
BytesPerLine : INTEGER;
PALETTETYPE : INTEGER;
Filler : ARRAY [0..57] OF BYTE;
END;
VAR
header: PCXHeader;
width, depth: WORD;
colors: WORD;
ImageFile: FILE;
BytesRead : WORD;
IsPCX : BOOLEAN;
BEGIN
IsPCX := FALSE;
Assign (ImageFile, FName);
Reset (ImageFile, 1);
BlockRead (ImageFile, header, SizeOf (header), BytesRead);
Close (ImageFile);
IF (IOResult = 0) AND (BytesRead = SizeOf (header)) THEN
WITH header DO
IF (Signature = #10) AND (Ord(Version) in [0,2,3,4,5]) THEN
BEGIN
IsPCX := TRUE;
width := XMax - XMin + 1;
depth := YMax - YMin + 1;
colors := 1 SHL (Ord(Planes)*Ord(BitsPerPixel));
ImageType := 'PCX';
ImageWidth := Width;
ImageHeight := Depth;
Str (colors:5, ImageColors);
ImageColors := ImageColors + ' ]';
END;
GetPCXInfo := IsPCX;
END;
FUNCTION IsImage (CONST fFile: STRING; VAR iWidth, iHeight: LONGINT; VAR iColors, GIFLite: STRING): STRING;
BEGIN
ImageType := '';
ImageWidth := 0;
ImageHeight := 0;
ImageColors := '';
GIFl := '';
IF GetGIFInfo (fFile)
OR GetJPGInfo (fFile)
OR GetBMPInfo (fFile)
OR GetPNGInfo (fFile)
OR GetPCXInfo (fFile)
THEN BEGIN
iWidth := ImageWidth;
iHeight := ImageHeight;
iColors := ImageColors;
GIFlite := Gifl;
END;
IsImage := ImageType;
END;
(*****************************************************************************)
END.